home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 26 / Cream of the Crop 26.iso / program / pa32v315.zip / TEST40.BAS < prev    next >
BASIC Source File  |  1996-11-26  |  11KB  |  390 lines
  1. Attribute VB_Name = "FileModule"
  2. ' Tuomas Salste
  3. ' File name parsing library
  4. ' Included as an example for Project Analyzer
  5. ' These functions will not necessarily work
  6.  
  7. Option Explicit
  8. DefInt A-Z
  9.  
  10. Type FilenameType
  11.    drive As String '* 8
  12.    Path As String '* 63
  13.    Filename As String '* 12
  14.    Basename As String '* 8
  15.    Extension As String '* 3
  16. End Type
  17.  
  18. ' Global and Public mean the same here
  19. Global FName As FilenameType
  20. Public FName2 As FilenameType
  21.  
  22. ' Different types of Consts
  23. Global Const DRIVE_FLOPPY = 2
  24. Public Const DRIVE_FIXED = 1
  25. Private Const DRIVE_NETWORK = 0
  26. Const DRIVE_CRASHED = -1 ' This is Private
  27.  
  28. ' DiskSpaceFree function uses this in SETUPKIT.DLL
  29. ' Not needed if not used
  30. Declare Function DiskSpaceFree_DLL Lib "SETUPKIT.DLL" Alias "DiskSpaceFree" () As Long
  31.  
  32.  
  33. Function AbsPath(ByVal BaseDir As String, ByVal Path As String) As String
  34. ' Gives Absolute Path from Relative Path
  35.  
  36. Dim GivenPath As FilenameType
  37. Dim Result As Integer
  38. Result = FileNameSplit(Path, GivenPath)
  39. If GivenPath.drive <> "" Then
  40.     On Error Resume Next
  41.     BaseDir = CurDir(GivenPath.drive)
  42.     If Err Then
  43.         BaseDir = GivenPath.drive + "\"
  44.     End If
  45.     On Error GoTo 0
  46. Else
  47.     If BaseDir = "" Then
  48.         BaseDir = CurDir
  49.     End If
  50. End If
  51.  
  52. Dim nDir As String
  53. Do While Path <> ""
  54.     nDir = NextDir(Path)
  55.     Select Case nDir
  56.         Case ".."
  57.             Dim BackPath As FilenameType
  58.             Result = FileNameSplit(BaseDir, BackPath)
  59.             BaseDir = BackPath.Path
  60.         Case "."
  61.         Case "\"
  62.             BaseDir = DriveOnly(BaseDir) + "\"
  63.         Case Else
  64.             BaseDir = PathNameWithSlash(BaseDir) & nDir
  65.     End Select
  66. Loop
  67. AbsPath = UCase(BaseDir)
  68.  
  69. End Function
  70.  
  71. Function Basenameonly(ByVal FileSpec As String) As String
  72. ' Returns the base name of a filespec
  73. ' FileSpec can be a directory name too
  74.  
  75. Dim Filename As FilenameType
  76. Dim Result As Integer
  77. Result = FileNameSplit(FileSpec, Filename)
  78. Basenameonly = Filename.Basename
  79.  
  80. End Function
  81.  
  82. Function ChangeFilenameExtension(ByVal OldFilename As String, ByVal NewExtension As String) As String
  83. ' Example:
  84. ' ChangeFilenameExtension("AUTOEXEC.BAT", "TMP")
  85. ' results in "AUTOEXEC.TMP"
  86. ' Returns "" in error
  87.  
  88. Dim File As FilenameType
  89. If FileNameSplit(OldFilename, File) Then
  90.     File.Extension = NewExtension
  91.     File.Filename = File.Basename & "." & File.Extension
  92.     ChangeFilenameExtension = FileNameExpand(File)
  93. Else
  94.     Exit Function
  95. End If
  96.  
  97. End Function
  98.  
  99. '------------------------------------------------
  100. ' Get the disk space free for the current drive
  101. '------------------------------------------------
  102. Function DiskSpaceFree(drive As String) As Long
  103. Dim OldDrive As String
  104. OldDrive = DriveOnly(CurDir)
  105.  
  106. On Error Resume Next
  107. ChDrive drive
  108. If Err = 0 Then
  109.     DiskSpaceFree = DiskSpaceFree_DLL()
  110. End If
  111. ChDrive OldDrive
  112.  
  113. End Function
  114.  
  115. Function DriveOnly(ByVal FileSpec As String) As String
  116. ' Returns the drive "D:"
  117.  
  118. Dim File As FilenameType
  119. If FileNameSplit(FileSpec, File) Then
  120.     DriveOnly = File.drive
  121. End If
  122.  
  123. End Function
  124.  
  125. Function DriveType(ByVal DriveLetter As String, DriveListBox As DriveListBox) As Integer
  126. ' Returns the type of a drive
  127. ' Type is one of the following:
  128. ' DRIVE_FLOPPY, DRIVE_FIXED, DRIVE_NETWORK
  129.  
  130. Dim i As Integer
  131. For i = 0 To DriveListBox.ListCount - 1
  132.     If StrComp(Left(DriveListBox.List(i), 1), Left(DriveLetter, 1), 1) = 0 Then
  133.         If Len(DriveListBox.List(i)) = 2 Then
  134.             DriveType = DRIVE_FLOPPY
  135.         ElseIf Mid(DriveListBox.List(i), 3, 2) = "\\" Then
  136.             DriveType = DRIVE_NETWORK
  137.         Else
  138.             
  139.             DriveType = DRIVE_FIXED
  140.         End If
  141.         Exit For
  142.     End If
  143. Next
  144.  
  145. End Function
  146.  
  147. Function ExtensionOnly(ByVal File As String) As String
  148. ' Returns file name extension "BAS"
  149. ' This is a global function that will be overridden
  150. ' by local function ExtensionOnly defined in PROJTEST.FRM
  151. ' So this function is dead
  152.  
  153. Dim Filename As FilenameType
  154. Dim Result As Integer
  155. Result = FileNameSplit(File, Filename)
  156. ExtensionOnly = Filename.Extension
  157.  
  158. End Function
  159.  
  160. Private Function FileNameExpand(Filename As FilenameType) As String
  161. ' Assembles a qualified file name from separate fields
  162.  
  163. Dim Delimiter$
  164. If Len(RTrim$(Filename.drive)) > 2 Then
  165.     If Filename.drive = String$(8, 0) Then
  166.         FileNameExpand$ = ""
  167.     Else
  168.         FileNameExpand$ = RTrim$(Filename.drive)
  169.     End If
  170. Else
  171.     If Right$(RTrim$(Filename.Path), 1) = ":" Or RTrim$(Filename.Path) = "" Or Right$(RTrim$(Filename.Path), 1) = "\" Then
  172.     Else
  173.         Delimiter$ = "\"
  174.     End If
  175.     If Left$(Filename.Path, 2) = RTrim$(Filename.drive) Then
  176.         FileNameExpand$ = UCase$(RTrim$(Filename.Path) + Delimiter$ + RTrim$(Filename.Filename))
  177.     Else
  178.         FileNameExpand$ = UCase$(RTrim$(Filename.drive) + RTrim$(Filename.Path) + Delimiter$ + RTrim$(Filename.Filename))
  179.     End If
  180. End If
  181.  
  182. End Function
  183.  
  184. Function FilenameOnly(ByVal FileSpec As String) As String
  185. ' Returns the file name part of a FileSpec "FILENAME.BAS"
  186.  
  187. Dim File As FilenameType
  188. If FileNameSplit(FileSpec, File) Then
  189.     FilenameOnly = File.Filename
  190. End If
  191.  
  192. End Function
  193.  
  194. Function FileNameSplit(ByVal FilenameString$, Filename As FilenameType) As Integer
  195. ' Splits a file name into separate fields
  196.  
  197. Dim er As Integer
  198. Dim FilNam$
  199. Dim Colon As Integer
  200. Dim NoDrive As Integer
  201. Dim c As Integer
  202.  
  203. FilNam$ = UCase$(FilenameString$)
  204. Filename.drive = ""
  205. Filename.Path = ""
  206. Filename.Filename = ""
  207. Filename.Basename = ""
  208. Filename.Extension = ""
  209. Colon = InStr(FilNam$, ":")
  210. If Colon = 2 Then
  211.     Filename.drive = Left$(FilNam$, 2)
  212. ElseIf Colon Then
  213.     If Len(FilNam$) > Colon Or Colon < 4 Or Colon > 5 Then
  214.         er = True
  215.     Else
  216.         NoDrive = True
  217.         Filename.drive = Left$(FilNam$, Colon)
  218.     End If
  219. End If
  220. If er = 0 And NoDrive = False Then
  221.     For c = Len(FilNam$) To 1 + Len(RTrim$(Filename.drive)) Step -1
  222.         If Mid$(FilNam$, c, 1) = "\" Then
  223.             If c = Len(RTrim$(Filename.drive)) + 1 Then
  224.                 Filename.Path = Left$(FilNam$, c)
  225.             Else
  226.                 Filename.Path = Left$(FilNam$, c - 1)
  227.             End If
  228.             Exit For
  229.         End If
  230.     Next
  231.     If RTrim$(Mid$(FilNam$, c + 1)) <> ".." Then
  232.         If InStr(Mid$(FilNam$, c + 1), ".") Then
  233.             Filename.Basename = Left$(Left$(Mid$(FilNam$, c + 1), InStr(Mid$(FilNam$, c + 1), ".") - 1), 8)
  234.             Filename.Extension = Mid$(Mid$(FilNam$, c + 1), InStr(Mid$(FilNam$, c + 1), ".") + 1, 3)
  235.         Else
  236.             Filename.Basename = Mid$(FilNam$, c + 1)
  237.         End If
  238.     Else
  239.         Filename.Path = RTrim$(Filename.Path) + ".."
  240.     End If
  241.     If RTrim$(Filename.Basename) = "" And RTrim$(Filename.Extension) <> "" Then
  242.         er = True
  243.         Filename.Extension = ""
  244.         Filename.Path = ""
  245.         Filename.drive = ""
  246.     Else
  247.         If Len(RTrim$(Filename.Extension)) Then
  248.             Filename.Filename = RTrim$(Filename.Basename) + "." + Filename.Extension
  249.         Else
  250.             Filename.Filename = RTrim$(Filename.Basename)
  251.         End If
  252.         If RTrim$(Filename.Filename) = "." Then Filename.Filename = ""
  253.     End If
  254. End If
  255. If er Then
  256.     FileNameSplit% = False
  257. Else
  258.     FileNameSplit% = True
  259. End If
  260.  
  261. End Function
  262.  
  263. Function IsDir(ByVal FileSpec As String) As Integer
  264.  
  265. Dim Result As Integer
  266. On Local Error Resume Next
  267. Result = GetAttr(FileSpec)
  268. If Err = 0 And Result = 16 Then ' ATTR_DIRECTORY= 16
  269.     IsDir = True
  270. End If
  271.  
  272. End Function
  273.  
  274. Function IsFile(ByVal FileSpec As String) As Integer
  275. ' Returns True if a file called Filename exists
  276. ' Filename CAN NOT contain wildcards
  277.  
  278. Dim Result As String
  279. On Local Error Resume Next
  280. Result = Dir(FileSpec)
  281. If Err = 0 And LCase(Result) = LCase(FilenameOnly(FileSpec)) And Result <> "" Then
  282.     IsFile = True
  283. End If
  284.  
  285. End Function
  286.  
  287. Function IsFileSpec(ByVal Filename As String) As Integer
  288. ' Returns True if Filename is
  289. ' a file, a directory or a volume label
  290. ' Filename must not contain any wildcards
  291.  
  292. Dim Result As Integer
  293. On Local Error Resume Next
  294. Result = GetAttr(Filename)
  295. If Err = 0 Then IsFileSpec = True
  296.  
  297. End Function
  298.  
  299. Function MatchesTemplate%(TestText$, Template$)
  300. ' Checks if a file name matches Template ("FILENAME.BAS", "*.BAS")
  301.  
  302. Dim CheckLen As Integer, c As Integer
  303. Dim TChar$, NoMatch As Integer
  304.  
  305. If Len(Template$) > Len(TestText$) Then
  306.     CheckLen = Len(Template$)
  307. Else
  308.     CheckLen = Len(TestText$)
  309. End If
  310. For c = 1 To CheckLen
  311.     TChar$ = Mid$(Template$, c, 1)
  312.     Select Case TChar$
  313.         Case "?"
  314.         Case "*"
  315.             Exit For
  316.         Case Mid$(TestText$, c, 1)
  317.         Case ""
  318.             NoMatch = True
  319.             Exit For
  320.         Case Else
  321.             NoMatch = True
  322.             Exit For
  323.     End Select
  324. Next
  325. If Len(Template$) > Len(TestText$) Then
  326.     If InStr(Template$, "*") = False And Mid$(Template$, Len(TestText$) + 1, Len(Template$) - Len(TestText$)) <> String$(Len(Template$) - Len(TestText$), "?") Then
  327.         NoMatch = True
  328.     End If
  329. End If
  330. If Not NoMatch Then MatchesTemplate = True
  331.  
  332. End Function
  333.  
  334. Function NextDir(Path As String) As String
  335. ' Returns the next directory name in a long Path string
  336. ' NextDir("D:\VB30\LIB\FILENAME.BAS") = "VB30"
  337.  
  338. Dim NewPath As String
  339. If Mid(Path, 2, 1) = ":" Then
  340.     NewPath = Mid(Path, 3)
  341. Else
  342.     NewPath = Path
  343. End If
  344. Select Case InStr(NewPath, "\")
  345.     Case 0
  346.         NextDir = NewPath
  347.         Path = ""
  348.     Case 1
  349.         NextDir = "\"
  350.         Path = Mid(NewPath, 2)
  351.     Case Else
  352.         NextDir = Left(NewPath, InStr(NewPath, "\") - 1)
  353.         Path = Mid(NewPath, InStr(NewPath, "\") + 1)
  354. End Select
  355.  
  356. End Function
  357.  
  358.  
  359. Function PathnameWithoutSlash(ByVal FileSpec As String) As String
  360. ' Returns a path name from a filespec without the ending slash
  361. ' The result can be used in ChDir, for example
  362. ' PathnameWithoutSlash("D:\VB30\LIB\FILENAME.BAS") = "D:\VB30\LIB"
  363.  
  364. Dim File As FilenameType
  365. If FileNameSplit(FileSpec, File) Then
  366.     PathnameWithoutSlash = File.Path
  367. End If
  368.  
  369. End Function
  370.  
  371. Function PathNameWithSlash(ByVal Path$) As String
  372. ' Returns a path name without the ending slash
  373. ' The result can be used in building filespecs, for example
  374. ' PathnameWithSlash("D:\VB30\LIB") = "D:\VB30\LIB\"
  375.  
  376. If Right$(RTrim$(Path$), 1) = ":" Or RTrim$(Path$) = "" Or Right$(RTrim$(Path$), 1) = "\" Then
  377.     PathNameWithSlash = Path$
  378. Else
  379.     If IsFile(Path$) Then
  380.         PathNameWithSlash = PathNameWithSlash(AbsPath(Path$, ".."))
  381.     Else
  382.         PathNameWithSlash = Path$ + "\"
  383.     End If
  384. End If
  385.  
  386. End Function
  387.  
  388.  
  389.  
  390.